home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / lib / perl5 / Params / ValidatePP.pm < prev    next >
Encoding:
Perl POD Document  |  2009-12-01  |  19.0 KB  |  715 lines
  1. package Params::Validate;
  2.  
  3. use strict;
  4. use warnings;
  5.  
  6. use Scalar::Util ();
  7.  
  8. # suppress subroutine redefined warnings if we tried to load the XS
  9. # version and failed.
  10. no warnings 'redefine';
  11.  
  12. BEGIN {
  13.     sub SCALAR ()    {1}
  14.     sub ARRAYREF ()  {2}
  15.     sub HASHREF ()   {4}
  16.     sub CODEREF ()   {8}
  17.     sub GLOB ()      {16}
  18.     sub GLOBREF ()   {32}
  19.     sub SCALARREF () {64}
  20.     sub UNKNOWN ()   {128}
  21.     sub UNDEF ()     {256}
  22.     sub OBJECT ()    {512}
  23.  
  24.     sub HANDLE ()  { 16 | 32 }
  25.     sub BOOLEAN () { 1 | 256 }
  26. }
  27.  
  28. # Various internals notes (for me and any future readers of this
  29. # monstrosity):
  30. #
  31. # - A lot of the weirdness is _intentional_, because it optimizes for
  32. #   the _success_ case.  It does not really matter how slow the code is
  33. #   after it enters a path that leads to reporting failure.  But the
  34. #   "success" path should be as fast as possible.
  35. #
  36. # -- We only calculate $called as needed for this reason, even though it
  37. #    means copying code all over.
  38. #
  39. # - All the validation routines need to be careful never to alter the
  40. #   references that are passed.
  41. #
  42. # -- The code assumes that _most_ callers will not be using the
  43. #    skip_leading or ignore_case features.  In order to not alter the
  44. #    references passed in, we copy them wholesale when normalizing them
  45. #    to make these features work.  This is slower but lets us be faster
  46. #    when not using them.
  47.  
  48. # Matt Sergeant came up with this prototype, which slickly takes the
  49. # first array (which should be the caller's @_), and makes it a
  50. # reference.  Everything after is the parameters for validation.
  51. sub validate_pos (\@@) {
  52.     return if $NO_VALIDATION && !defined wantarray;
  53.  
  54.     my $p = shift;
  55.  
  56.     my @specs = @_;
  57.  
  58.     my @p = @$p;
  59.     if ($NO_VALIDATION) {
  60.  
  61.         # if the spec is bigger that's where we can start adding
  62.         # defaults
  63.         for ( my $x = $#p + 1; $x <= $#specs; $x++ ) {
  64.             $p[$x] = $specs[$x]->{default}
  65.                 if ref $specs[$x] && exists $specs[$x]->{default};
  66.         }
  67.  
  68.         return wantarray ? @p : \@p;
  69.     }
  70.  
  71.     # I'm too lazy to pass these around all over the place.
  72.     local $options ||= _get_options( ( caller(0) )[0] )
  73.         unless defined $options;
  74.  
  75.     my $min = 0;
  76.  
  77.     while (1) {
  78.         last
  79.             unless (
  80.             ref $specs[$min]
  81.             ? !( exists $specs[$min]->{default} || $specs[$min]->{optional} )
  82.             : $specs[$min]
  83.             );
  84.  
  85.         $min++;
  86.     }
  87.  
  88.     my $max = scalar @specs;
  89.  
  90.     my $actual = scalar @p;
  91.     unless ( $actual >= $min
  92.         && ( $options->{allow_extra} || $actual <= $max ) ) {
  93.         my $minmax = (
  94.             $options->{allow_extra}
  95.             ? "at least $min"
  96.             : ( $min != $max ? "$min - $max" : $max )
  97.         );
  98.  
  99.         my $val = $options->{allow_extra} ? $min : $max;
  100.         $minmax .= $val != 1 ? ' were' : ' was';
  101.  
  102.         my $called = _get_called();
  103.  
  104.         $options->{on_fail}->( "$actual parameter"
  105.                 . ( $actual != 1 ? 's'    : '' ) . " "
  106.                 . ( $actual != 1 ? 'were' : 'was' )
  107.                 . " passed to $called but $minmax expected\n" );
  108.     }
  109.  
  110.     my $bigger = $#p > $#specs ? $#p : $#specs;
  111.     foreach ( 0 .. $bigger ) {
  112.         my $spec = $specs[$_];
  113.  
  114.         next unless ref $spec;
  115.  
  116.         if ( $_ <= $#p ) {
  117.             my $value = defined $p[$_] ? qq|"$p[$_]"| : 'undef';
  118.             _validate_one_param( $p[$_], \@p, $spec,
  119.                 "Parameter #" . ( $_ + 1 ) . " ($value)" );
  120.         }
  121.  
  122.         $p[$_] = $spec->{default} if $_ > $#p && exists $spec->{default};
  123.     }
  124.  
  125.     _validate_pos_depends( \@p, \@specs );
  126.  
  127.     foreach (
  128.         grep {
  129.                    defined $p[$_]
  130.                 && !ref $p[$_]
  131.                 && ref $specs[$_]
  132.                 && $specs[$_]{untaint}
  133.         } 0 .. $bigger
  134.         ) {
  135.         ( $p[$_] ) = $p[$_] =~ /(.+)/;
  136.     }
  137.  
  138.     return wantarray ? @p : \@p;
  139. }
  140.  
  141. sub _validate_pos_depends {
  142.     my ( $p, $specs ) = @_;
  143.  
  144.     for my $p_idx ( 0 .. $#$p ) {
  145.         my $spec = $specs->[$p_idx];
  146.  
  147.         next
  148.             unless $spec
  149.                 && UNIVERSAL::isa( $spec, 'HASH' )
  150.                 && exists $spec->{depends};
  151.  
  152.         my $depends = $spec->{depends};
  153.  
  154.         if ( ref $depends ) {
  155.             require Carp;
  156.             local $Carp::CarpLevel = 2;
  157.             Carp::croak(
  158.                 "Arguments to 'depends' for validate_pos() must be a scalar");
  159.         }
  160.  
  161.         my $p_size = scalar @$p;
  162.         if ( $p_size < $depends - 1 ) {
  163.             my $error
  164.                 = (   "Parameter #"
  165.                     . ( $p_idx + 1 )
  166.                     . " depends on parameter #"
  167.                     . $depends
  168.                     . ", which was not given" );
  169.  
  170.             $options->{on_fail}->($error);
  171.         }
  172.     }
  173.     return 1;
  174. }
  175.  
  176. sub _validate_named_depends {
  177.     my ( $p, $specs ) = @_;
  178.  
  179.     foreach my $pname ( keys %$p ) {
  180.         my $spec = $specs->{$pname};
  181.  
  182.         next
  183.             unless $spec
  184.                 && UNIVERSAL::isa( $spec, 'HASH' )
  185.                 && $spec->{depends};
  186.  
  187.         unless ( UNIVERSAL::isa( $spec->{depends}, 'ARRAY' )
  188.             || !ref $spec->{depends} ) {
  189.             require Carp;
  190.             local $Carp::CarpLevel = 2;
  191.             Carp::croak(
  192.                 "Arguments to 'depends' must be a scalar or arrayref");
  193.         }
  194.  
  195.         foreach my $depends_name (
  196.             ref $spec->{depends}
  197.             ? @{ $spec->{depends} }
  198.             : $spec->{depends}
  199.             ) {
  200.             unless ( exists $p->{$depends_name} ) {
  201.                 my $error
  202.                     = (   "Parameter '$pname' depends on parameter '"
  203.                         . $depends_name
  204.                         . "', which was not given" );
  205.  
  206.                 $options->{on_fail}->($error);
  207.             }
  208.         }
  209.     }
  210. }
  211.  
  212. sub validate (\@$) {
  213.     return if $NO_VALIDATION && !defined wantarray;
  214.  
  215.     my $p = $_[0];
  216.  
  217.     my $specs = $_[1];
  218.     local $options = _get_options( ( caller(0) )[0] ) unless defined $options;
  219.  
  220.     if ( ref $p eq 'ARRAY' ) {
  221.  
  222.         # we were called as validate( @_, ... ) where @_ has a
  223.         # single element, a hash reference
  224.         if ( ref $p->[0] ) {
  225.             $p = { %{ $p->[0] } };
  226.         }
  227.         elsif ( @$p % 2 ) {
  228.             my $called = _get_called();
  229.  
  230.             $options->{on_fail}
  231.                 ->(   "Odd number of parameters in call to $called "
  232.                     . "when named parameters were expected\n" );
  233.         }
  234.         else {
  235.             $p = {@$p};
  236.         }
  237.     }
  238.  
  239.     if ( $options->{normalize_keys} ) {
  240.         $specs = _normalize_callback( $specs, $options->{normalize_keys} );
  241.         $p     = _normalize_callback( $p,     $options->{normalize_keys} );
  242.     }
  243.     elsif ( $options->{ignore_case} || $options->{strip_leading} ) {
  244.         $specs = _normalize_named($specs);
  245.         $p     = _normalize_named($p);
  246.     }
  247.  
  248.     if ($NO_VALIDATION) {
  249.         return (
  250.             wantarray
  251.             ? (
  252.  
  253.                 # this is a hash containing just the defaults
  254.                 (
  255.                     map { $_ => $specs->{$_}->{default} }
  256.                         grep {
  257.                         ref $specs->{$_} && exists $specs->{$_}->{default}
  258.                         }
  259.                         keys %$specs
  260.                 ),
  261.                 (
  262.                     ref $p eq 'ARRAY'
  263.                     ? (
  264.                         ref $p->[0]
  265.                         ? %{ $p->[0] }
  266.                         : @$p
  267.                         )
  268.                     : %$p
  269.                 )
  270.                 )
  271.             : do {
  272.                 my $ref = (
  273.                     ref $p eq 'ARRAY'
  274.                     ? (
  275.                         ref $p->[0]
  276.                         ? $p->[0]
  277.                         : {@$p}
  278.                         )
  279.                     : $p
  280.                 );
  281.  
  282.                 foreach (
  283.                     grep {
  284.                         ref $specs->{$_}
  285.                             && exists $specs->{$_}->{default}
  286.                     }
  287.                     keys %$specs
  288.                     ) {
  289.                     $ref->{$_} = $specs->{$_}->{default}
  290.                         unless exists $ref->{$_};
  291.                 }
  292.  
  293.                 return $ref;
  294.                 }
  295.         );
  296.     }
  297.  
  298.     _validate_named_depends( $p, $specs );
  299.  
  300.     unless ( $options->{allow_extra} ) {
  301.         if ( my @unmentioned = grep { !exists $specs->{$_} } keys %$p ) {
  302.             my $called = _get_called();
  303.  
  304.             $options->{on_fail}->( "The following parameter"
  305.                     . ( @unmentioned > 1 ? 's were' : ' was' )
  306.                     . " passed in the call to $called but "
  307.                     . ( @unmentioned > 1 ? 'were' : 'was' )
  308.                     . " not listed in the validation options: @unmentioned\n"
  309.             );
  310.         }
  311.     }
  312.  
  313.     my @missing;
  314.  
  315.     # the iterator needs to be reset in case the same hashref is being
  316.     # passed to validate() on successive calls, because we may not go
  317.     # through all the hash's elements
  318.     keys %$specs;
  319. OUTER:
  320.     while ( my ( $key, $spec ) = each %$specs ) {
  321.         if (
  322.             !exists $p->{$key}
  323.             && (
  324.                 ref $spec
  325.                 ? !(
  326.                     do {
  327.  
  328.                         # we want to short circuit the loop here if we
  329.                         # can assign a default, because there's no need
  330.                         # check anything else at all.
  331.                         if ( exists $spec->{default} ) {
  332.                             $p->{$key} = $spec->{default};
  333.                             next OUTER;
  334.                         }
  335.                     }
  336.                     || do {
  337.  
  338.                         # Similarly, an optional parameter that is
  339.                         # missing needs no additional processing.
  340.                         next OUTER if $spec->{optional};
  341.                     }
  342.                 )
  343.                 : $spec
  344.             )
  345.             ) {
  346.             push @missing, $key;
  347.         }
  348.  
  349.         # Can't validate a non hashref spec beyond the presence or
  350.         # absence of the parameter.
  351.         elsif ( ref $spec ) {
  352.             my $value = defined $p->{$key} ? qq|"$p->{$key}"| : 'undef';
  353.             _validate_one_param( $p->{$key}, $p, $spec,
  354.                 "The '$key' parameter ($value)" );
  355.         }
  356.     }
  357.  
  358.     if (@missing) {
  359.         my $called = _get_called();
  360.  
  361.         my $missing = join ', ', map {"'$_'"} @missing;
  362.         $options->{on_fail}->( "Mandatory parameter"
  363.                 . ( @missing > 1 ? 's' : '' )
  364.                 . " $missing missing in call to $called\n" );
  365.     }
  366.  
  367.     # do untainting after we know everything passed
  368.     foreach my $key (
  369.         grep {
  370.                    defined $p->{$_}
  371.                 && !ref $p->{$_}
  372.                 && ref $specs->{$_}
  373.                 && $specs->{$_}{untaint}
  374.         }
  375.         keys %$p
  376.         ) {
  377.         ( $p->{$key} ) = $p->{$key} =~ /(.+)/;
  378.     }
  379.  
  380.     return wantarray ? %$p : $p;
  381. }
  382.  
  383. sub validate_with {
  384.     return if $NO_VALIDATION && !defined wantarray;
  385.  
  386.     my %p = @_;
  387.  
  388.     local $options = _get_options( ( caller(0) )[0], %p );
  389.  
  390.     unless ($NO_VALIDATION) {
  391.         unless ( exists $options->{called} ) {
  392.             $options->{called} = ( caller( $options->{stack_skip} ) )[3];
  393.         }
  394.  
  395.     }
  396.  
  397.     if ( UNIVERSAL::isa( $p{spec}, 'ARRAY' ) ) {
  398.         return validate_pos( @{ $p{params} }, @{ $p{spec} } );
  399.     }
  400.     else {
  401.  
  402.         # intentionally ignore the prototype because this contains
  403.         # either an array or hash reference, and validate() will
  404.         # handle either one properly
  405.         return &validate( $p{params}, $p{spec} );
  406.     }
  407. }
  408.  
  409. sub _normalize_callback {
  410.     my ( $p, $func ) = @_;
  411.  
  412.     my %new;
  413.  
  414.     foreach my $key ( keys %$p ) {
  415.         my $new_key = $func->($key);
  416.  
  417.         unless ( defined $new_key ) {
  418.             die
  419.                 "The normalize_keys callback did not return a defined value when normalizing the key '$key'";
  420.         }
  421.  
  422.         if ( exists $new{$new_key} ) {
  423.             die
  424.                 "The normalize_keys callback returned a key that already exists, '$new_key', when normalizing the key '$key'";
  425.         }
  426.  
  427.         $new{$new_key} = $p->{$key};
  428.     }
  429.  
  430.     return \%new;
  431. }
  432.  
  433. sub _normalize_named {
  434.  
  435.     # intentional copy so we don't destroy original
  436.     my %h = ( ref $_[0] ) =~ /ARRAY/ ? @{ $_[0] } : %{ $_[0] };
  437.  
  438.     if ( $options->{ignore_case} ) {
  439.         $h{ lc $_ } = delete $h{$_} for keys %h;
  440.     }
  441.  
  442.     if ( $options->{strip_leading} ) {
  443.         foreach my $key ( keys %h ) {
  444.             my $new;
  445.             ( $new = $key ) =~ s/^\Q$options->{strip_leading}\E//;
  446.             $h{$new} = delete $h{$key};
  447.         }
  448.     }
  449.  
  450.     return \%h;
  451. }
  452.  
  453. sub _validate_one_param {
  454.     my ( $value, $params, $spec, $id ) = @_;
  455.  
  456.     if ( exists $spec->{type} ) {
  457.         unless ( defined $spec->{type}
  458.             && Scalar::Util::looks_like_number( $spec->{type} )
  459.             && $spec->{type} > 0 ) {
  460.             my $msg
  461.                 = "$id has a type specification which is not a number. It is ";
  462.             if ( defined $spec->{type} ) {
  463.                 $msg .= "a string - $spec->{type}";
  464.             }
  465.             else {
  466.                 $msg .= "undef";
  467.             }
  468.  
  469.             $msg
  470.                 .= ".\n Use the constants exported by Params::Validate to declare types.";
  471.  
  472.             $options->{on_fail}->($msg);
  473.         }
  474.  
  475.         unless ( _get_type($value) & $spec->{type} ) {
  476.             my $type = _get_type($value);
  477.  
  478.             my @is      = _typemask_to_strings($type);
  479.             my @allowed = _typemask_to_strings( $spec->{type} );
  480.             my $article = $is[0] =~ /^[aeiou]/i ? 'an' : 'a';
  481.  
  482.             my $called = _get_called(1);
  483.  
  484.             $options->{on_fail}->( "$id to $called was $article '@is', which "
  485.                     . "is not one of the allowed types: @allowed\n" );
  486.         }
  487.     }
  488.  
  489.     # short-circuit for common case
  490.     return
  491.         unless ( $spec->{isa}
  492.         || $spec->{can}
  493.         || $spec->{callbacks}
  494.         || $spec->{regex} );
  495.  
  496.     if ( exists $spec->{isa} ) {
  497.         foreach ( ref $spec->{isa} ? @{ $spec->{isa} } : $spec->{isa} ) {
  498.             unless ( eval { $value->isa($_) } ) {
  499.                 my $is = ref $value ? ref $value : 'plain scalar';
  500.                 my $article1 = $_  =~ /^[aeiou]/i ? 'an' : 'a';
  501.                 my $article2 = $is =~ /^[aeiou]/i ? 'an' : 'a';
  502.  
  503.                 my $called = _get_called(1);
  504.  
  505.                 $options->{on_fail}
  506.                     ->(   "$id to $called was not $article1 '$_' "
  507.                         . "(it is $article2 $is)\n" );
  508.             }
  509.         }
  510.     }
  511.  
  512.     if ( exists $spec->{can} ) {
  513.         foreach ( ref $spec->{can} ? @{ $spec->{can} } : $spec->{can} ) {
  514.             unless ( eval { $value->can($_) } ) {
  515.                 my $called = _get_called(1);
  516.  
  517.                 $options->{on_fail}
  518.                     ->("$id to $called does not have the method: '$_'\n");
  519.             }
  520.         }
  521.     }
  522.  
  523.     if ( $spec->{callbacks} ) {
  524.         unless ( UNIVERSAL::isa( $spec->{callbacks}, 'HASH' ) ) {
  525.             my $called = _get_called(1);
  526.  
  527.             $options->{on_fail}->(
  528.                 "'callbacks' validation parameter for $called must be a hash reference\n"
  529.             );
  530.         }
  531.  
  532.         foreach ( keys %{ $spec->{callbacks} } ) {
  533.             unless ( UNIVERSAL::isa( $spec->{callbacks}{$_}, 'CODE' ) ) {
  534.                 my $called = _get_called(1);
  535.  
  536.                 $options->{on_fail}->(
  537.                     "callback '$_' for $called is not a subroutine reference\n"
  538.                 );
  539.             }
  540.  
  541.             unless ( $spec->{callbacks}{$_}->( $value, $params ) ) {
  542.                 my $called = _get_called(1);
  543.  
  544.                 $options->{on_fail}
  545.                     ->("$id to $called did not pass the '$_' callback\n");
  546.             }
  547.         }
  548.     }
  549.  
  550.     if ( exists $spec->{regex} ) {
  551.         unless ( ( defined $value ? $value : '' ) =~ /$spec->{regex}/ ) {
  552.             my $called = _get_called(1);
  553.  
  554.             $options->{on_fail}
  555.                 ->("$id to $called did not pass regex check\n");
  556.         }
  557.     }
  558. }
  559.  
  560. {
  561.  
  562.     # if it UNIVERSAL::isa the string on the left then its the type on
  563.     # the right
  564.     my %isas = (
  565.         'ARRAY'  => ARRAYREF,
  566.         'HASH'   => HASHREF,
  567.         'CODE'   => CODEREF,
  568.         'GLOB'   => GLOBREF,
  569.         'SCALAR' => SCALARREF,
  570.     );
  571.     my %simple_refs = map { $_ => 1 } keys %isas;
  572.  
  573.     sub _get_type {
  574.         return UNDEF unless defined $_[0];
  575.  
  576.         my $ref = ref $_[0];
  577.         unless ($ref) {
  578.  
  579.             # catches things like:  my $fh = do { local *FH; };
  580.             return GLOB if UNIVERSAL::isa( \$_[0], 'GLOB' );
  581.             return SCALAR;
  582.         }
  583.  
  584.         return $isas{$ref} if $simple_refs{$ref};
  585.  
  586.         foreach ( keys %isas ) {
  587.             return $isas{$_} | OBJECT if UNIVERSAL::isa( $_[0], $_ );
  588.         }
  589.  
  590.         # I really hope this never happens.
  591.         return UNKNOWN;
  592.     }
  593. }
  594.  
  595. {
  596.     my %type_to_string = (
  597.         SCALAR()    => 'scalar',
  598.         ARRAYREF()  => 'arrayref',
  599.         HASHREF()   => 'hashref',
  600.         CODEREF()   => 'coderef',
  601.         GLOB()      => 'glob',
  602.         GLOBREF()   => 'globref',
  603.         SCALARREF() => 'scalarref',
  604.         UNDEF()     => 'undef',
  605.         OBJECT()    => 'object',
  606.         UNKNOWN()   => 'unknown',
  607.     );
  608.  
  609.     sub _typemask_to_strings {
  610.         my $mask = shift;
  611.  
  612.         my @types;
  613.         foreach (
  614.             SCALAR,    ARRAYREF, HASHREF, CODEREF, GLOB, GLOBREF,
  615.             SCALARREF, UNDEF,    OBJECT,  UNKNOWN
  616.             ) {
  617.             push @types, $type_to_string{$_} if $mask & $_;
  618.         }
  619.         return @types ? @types : ('unknown');
  620.     }
  621. }
  622.  
  623. {
  624.     my %defaults = (
  625.         ignore_case   => 0,
  626.         strip_leading => 0,
  627.         allow_extra   => 0,
  628.         on_fail       => sub {
  629.             require Carp;
  630.             Carp::confess( $_[0] );
  631.         },
  632.         stack_skip     => 1,
  633.         normalize_keys => undef,
  634.     );
  635.  
  636.     *set_options = \&validation_options;
  637.  
  638.     sub validation_options {
  639.         my %opts = @_;
  640.  
  641.         my $caller = caller;
  642.  
  643.         foreach ( keys %defaults ) {
  644.             $opts{$_} = $defaults{$_} unless exists $opts{$_};
  645.         }
  646.  
  647.         $OPTIONS{$caller} = \%opts;
  648.     }
  649.  
  650.     sub _get_options {
  651.         my $caller = shift;
  652.  
  653.         if (@_) {
  654.  
  655.             return (
  656.                 $OPTIONS{$caller}
  657.                 ? {
  658.                     %{ $OPTIONS{$caller} },
  659.                     @_
  660.                     }
  661.                 : { %defaults, @_ }
  662.             );
  663.         }
  664.         else {
  665.             return (
  666.                 exists $OPTIONS{$caller}
  667.                 ? $OPTIONS{$caller}
  668.                 : \%defaults
  669.             );
  670.         }
  671.     }
  672. }
  673.  
  674. sub _get_called {
  675.     my $extra_skip = $_[0] || 0;
  676.  
  677.     # always add one more for this sub
  678.     $extra_skip++;
  679.  
  680.     my $called = (
  681.         exists $options->{called}
  682.         ? $options->{called}
  683.         : ( caller( $options->{stack_skip} + $extra_skip ) )[3]
  684.     );
  685.  
  686.     $called = 'N/A' unless defined $called;
  687.  
  688.     return $called;
  689. }
  690.  
  691. 1;
  692.  
  693. __END__
  694.  
  695. =head1 NAME
  696.  
  697. Params::ValidatePP - pure Perl implementation of Params::Validate
  698.  
  699. =head1 SYNOPSIS
  700.  
  701.   See Params::Validate
  702.  
  703. =head1 DESCRIPTION
  704.  
  705. This is a pure Perl implementation of Params::Validate.  See the
  706. Params::Validate documentation for details.
  707.  
  708. =head1 COPYRIGHT
  709.  
  710. Copyright (c) 2004-2007 David Rolsky.  All rights reserved.  This
  711. program is free software; you can redistribute it and/or modify it
  712. under the same terms as Perl itself.
  713.  
  714. =cut
  715.